home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d1 / filecat.arc / FMAIN01.INC < prev    next >
Text File  |  1986-05-14  |  15KB  |  515 lines
  1. VAR
  2.   INT24Err: Boolean;
  3.   INT24ErrCode: Byte;
  4.   OldINT24: Array [1..2] Of Integer;
  5.  
  6. Procedure INT24;
  7.   Begin
  8.     Inline
  9.      ($2E/$C6/$06/ INT24Err /$01/$89/$EC/$83/$C4/$08/$89/$F8/$2E/$A2/
  10.       INT24ErrCode /$58/$B0/$FF/$5B/$59/$5A/$5E/$5F/$5D/$1F/$07/$CF);
  11.     { Turbo:  PUSH BP                    (Save caller's stack frame
  12.               MOV  BP,SP                   Set up this procedure's stack frame
  13.               PUSH BP                     ?)
  14.       Inline: MOV  BYTE CS:[INT24Err],1  Set INT24Err to True
  15.               MOV  SP,BP                 Get correct SP;  ADD: Discard saved
  16.               ADD  SP,8                    BP, INT 24 return address & flags
  17.               MOV  AX,DI                 Get INT 24 error code
  18.               MOV  CS:[INT24ErrCode],AL  Save it in INT24ErrCode
  19.               POP  AX                    Pop all registers
  20.               MOV  AL,0FFH               Set FCB call error flag:
  21.               POP  BX                      will cause Turbo I/O error on file
  22.               POP  CX                      operations, no error on character
  23.               POP  DX                      operations
  24.               POP  SI
  25.               POP  DI
  26.               POP  BP
  27.               POP  DS
  28.               POP  ES
  29.               IRET                       Return to next instruction }
  30.   End;
  31.  
  32. Procedure INT24On;
  33.   Begin
  34.     INT24Err:=False;
  35.     With Regs Do
  36.      Begin
  37.       AX:=$3524;
  38.       MsDos(Regs);
  39.       If (OldINT24[1] Or OldINT24[2])=0 Then
  40.        Begin
  41.         OldINT24[1]:=ES;
  42.         OldINT24[2]:=BX;
  43.        End;
  44.       DS:=CSeg;
  45.       DX:=Ofs(INT24);
  46.       AX:=$2524;
  47.       MsDos(Regs);
  48.      End;
  49.   End;
  50.  
  51. Procedure INT24Off;
  52.   Begin
  53.     INT24Err:=False;
  54.     If OldINT24[1]<>0 Then
  55.       With Regs Do
  56.        Begin
  57.         DS:=OldINT24[1];
  58.         DX:=OldINT24[2];
  59.         AX:=$2524;
  60.         MsDos(Regs);
  61.        End;
  62.     OldINT24[1]:=0;
  63.     OldINT24[2]:=0;
  64.   End;
  65.  
  66. Function INT24Result: Integer;
  67.   VAR I:Integer;
  68.   Begin
  69.     I:=IOResult;
  70.     If INT24Err Then
  71.      Begin
  72.       I:=I+256*INT24ErrCode;
  73.       INT24On;
  74.      End;
  75.     INT24Result:=I;
  76.   End;
  77.  
  78. FUNCTION CheckDOSVersion:Str3;
  79.   VAR S,S1:Str3;
  80.   Begin
  81.     Regs.AX := $3000;       { Func.Call $30 (Get DOS Version Number) }
  82.     MsDos(Regs);
  83.     Str(Regs.AL,S);
  84.     Str(Regs.AH,S1);
  85.     CheckDOSVersion:=S+'.'+S1;
  86.     If NOT (S[1] in ['2','3']) then begin
  87.       ClrScr;
  88.       Write(^G);
  89.       GotoXY(10,17);
  90.       WriteLn('Sorry...  FILECAT requires DOS 2.X or greater.');
  91.       Halt;
  92.     End;
  93.   End; { function CheckDOSVersion }
  94.  
  95. FUNCTION ConstStr(C:Char; N:Integer) : Str80;
  96.   VAR S : String[80];
  97.   Begin
  98.     If N<0 then N:=0;
  99.     S[0] := Chr(N);
  100.     FillChar(S[1],N,C);
  101.     ConstStr := S;
  102.   End;
  103.  
  104. FUNCTION PrTest: Boolean;
  105.   VAR I : Integer;
  106.   Begin
  107.     Regs.ax:=$0200;
  108.     Regs.dx:=$0000;
  109.     Intr($17,Regs);
  110.     I := ((regs.ax and $FF00) shr 8);
  111.     If (I=144) then PrTest := True
  112.       Else PrTest := False;
  113.   End; { function PrTest }
  114.  
  115. FUNCTION MonitorType : Integer;
  116.   Begin
  117.     MonitorType := Mem[$0040:$0049];
  118.   End; { function MonitorType }
  119.  
  120. PROCEDURE HideCursor;
  121.   Begin
  122.     Inline($B9/$0F00/$B4/$01/$CD/$10);
  123.   End; { procedure HideCursor }
  124.  
  125. PROCEDURE RestoreCursor;
  126.   Begin
  127.     If MonitorType = 7 then                  { Mono }
  128.       Inline($B9/$0C0D/$B4/$01/$CD/$10)
  129.     Else Inline($B9/$0607/$B4/$01/$CD/$10);  { CGA }
  130.   End; { procedure RestoreCursor }
  131.  
  132. PROCEDURE Beep;
  133.   Begin
  134.     Sound(660);Delay(60);
  135.     Sound(440);Delay(60);
  136.     Sound(660);Delay(60);
  137.     Sound(440);Delay(60);
  138.     NoSound;
  139.   End;
  140.  
  141. FUNCTION Yes: Boolean;
  142.   VAR Ch:Char;
  143.   Begin
  144.     Repeat
  145.       Read(Kbd,Ch);
  146.       Ch:=UpCase(Ch);
  147.       If Not (Ch in ['Y','N']) then Beep;
  148.     Until Ch in ['Y','N'];
  149.     Yes := (Ch='Y');
  150.   End; { function Yes }
  151.  
  152. PROCEDURE DrawBox (Left, Right, Top, Bottom : Integer);
  153.   VAR
  154.    Index : Integer;
  155.   Begin
  156.     HideCursor;
  157.     GotoXY(Left,Top);
  158.     Write('┌');
  159.     For Index := Left+1 to Right-1 DO Begin
  160.       Write('─');
  161.     End;
  162.     Write('┐');
  163.     For Index := Top+1 to Bottom-1 Do Begin
  164.       GotoXY(Left,Index);
  165.       Write('│');
  166.       GotoXY(Right,Index);
  167.       Write('│');
  168.     End;
  169.     GotoXY(Left,Bottom);
  170.     Write('└');
  171.     For Index := Left+1 to Right-1 Do Begin
  172.       Write('─');
  173.     End;
  174.     Write('┘');
  175.     RestoreCursor;
  176.   End;
  177.  
  178. FUNCTION DOSDate:Str8;
  179.   TYPE
  180.     regpack = record
  181.                 ax,bx,cx,dx,bp,si,ds,es,flags: integer;
  182.               end;
  183.   VAR
  184.     recpack:       regpack;                {record for MsDos call}
  185.     month,day:     string[2];
  186.     year:          string[4];
  187.   begin
  188.     with recpack do
  189.     begin
  190.       ax := $2a shl 8;
  191.     end;
  192.     MsDos(recpack);                        { call function }
  193.     with recpack do
  194.     begin
  195.       str(cx,year);                        {convert to string}
  196.       str(dx mod 256,day);                     { " }
  197.       str(dx shr 8,month);                     { " }
  198.     end;
  199.     Year:=Copy(Year,3,2);
  200.     If Length(Day) = 1 then Day:='0'+Day;
  201.     DOSdate := month + '/' + day + '/' + year  ;
  202.   end;
  203.  
  204. FUNCTION Freespace:real;
  205.   VAR  fr : real;
  206.   Begin
  207.     with regs do
  208.     begin
  209.       dx := 0;
  210.       ah := $36;
  211.       MsDos(regs);
  212.       fr := bx;
  213.       if ax <> $FFFF then Freespace := fr * ax * cx else Freespace := 0
  214.     End;
  215.   End;  { function Freespace }
  216.  
  217. PROCEDURE SetDTA3;
  218.   Begin
  219.     Regs.AX := $1A00;       { Func.Call $1A (Set DTA) }
  220.     Regs.DS := Seg(DTA3);
  221.     Regs.DX := Ofs(DTA3);
  222.     MsDos(Regs);
  223.   End; { procedure SetDTA3 }
  224.  
  225. PROCEDURE SetASCIIZ(FName:Name);
  226.   VAR I:Integer;
  227.   Begin
  228.     FillChar(ASCIIZ,SizeOf(ASCIIZ),0);
  229.     For I:=1 to Length(FName) do ASCIIZ[I]:=FName[I];
  230.   End; { procedure SetASCIIZ }
  231.  
  232. PROCEDURE FindFirst3(Att:Integer);
  233.   Begin
  234.     SetDTA3;
  235.     Regs.AX := $4E00;       { Func.Call $4E (Find First) }
  236.     Regs.DS := Seg(ASCIIZ);
  237.     Regs.DX := Ofs(ASCIIZ);
  238.     Regs.CX := Att;
  239.     MsDos(Regs);
  240.     Error:=Regs.AX;
  241.   End; { procedure FindFirst3 }
  242.  
  243. PROCEDURE FindNext3;
  244.   Begin
  245.     SetDTA3;
  246.     Regs.AX := $4F00;       { Func.Call $4F (Find Next) }
  247.     Regs.DS := Seg(ASCIIZ);
  248.     Regs.DX := Ofs(ASCIIZ);
  249.     MsDos(Regs);
  250.     Error:=Regs.AX;
  251.   End; { procedure FindNext3 }
  252.  
  253. PROCEDURE GetName3;
  254.   VAR
  255.     I:Integer;
  256.     S,S1:String[15];
  257.     Name:Array[1..13] of Char;
  258.   Begin
  259.     S:=#0;
  260.     S1:='';
  261.     For I:=31 to 43 do Name[I-30]:=DTA3[I];
  262.     For I:=31 to 30+Pos(S,Name) do S1:=S1+DTA3[I];
  263.     I:=Pos('.',S1);
  264.     Entry[EntryNum].EStatus:=0;
  265.     If I=0 then Entry[EntryNum].EName:=S1
  266.       Else begin
  267.         Entry[EntryNum].EName:=Copy(S1,1,I-1);
  268.         Entry[EntryNum].EExt:=Copy(S1,I+1,3);
  269.       End;
  270.     S:=Entry[EntryNum].EName;
  271.     S:=S+ConstStr(' ',8-Length(S));
  272.     Entry[EntryNum].EName:=S;
  273.     S:=Entry[EntryNum].EExt;
  274.     S:=S+ConstStr(' ',3-Length(S));
  275.     Entry[EntryNum].EExt:=S;
  276.     Entry[EntryNum].ETime:=Ord(DTA3[24]);
  277.     Entry[EntryNum].ETime:=Entry[EntryNum].ETime shl 8;
  278.     Entry[EntryNum].ETime:=Entry[EntryNum].ETime or Ord(DTA3[23]);
  279.     Entry[EntryNum].EDate:=Ord(DTA3[26]);
  280.     Entry[EntryNum].EDate:=Entry[EntryNum].EDate shl 8;
  281.     Entry[EntryNum].EDate:=Entry[EntryNum].EDate or Ord(DTA3[25]);
  282.     For I:=1 to 4 do Entry[EntryNum].ESize[I]:=Ord(DTA3[I+26]);
  283.   End; { procedure GetName3 }
  284.  
  285. PROCEDURE BuildArray;
  286.   VAR I:Integer;
  287.   Begin
  288.     INT24On;
  289.     {$I-}
  290.     ChDir(SourceDirectory);
  291.     {$I+}
  292.     I:=INT24Result;
  293.     INT24Off;
  294.     If I<>0 then Begin
  295.       Beep;
  296.     End;
  297.     EntryNum:=0;
  298.     FillChar(Entry,SizeOf(Entry),0);
  299.     SetASCIIZ('*.*');
  300.     FindFirst3(0);
  301.     If Error=0 then begin
  302.       EntryNum:=EntryNum+1;
  303.       GetName3;
  304.     End;
  305.     If Error=0 then begin
  306.       Repeat
  307.       FindNext3;
  308.       If (Error=0) and (EntryNum<250) then begin
  309.         EntryNum:=EntryNum+1;
  310.         GetName3;
  311.       End;
  312.       Until Error<>0;
  313.     End;
  314.   End; { procedure BuildArray }
  315.  
  316. PROCEDURE DisplayID;
  317.   Procedure Center(R:Integer;D:Str80);
  318.     Begin
  319.       GotoXY((80 -Length(D)) div 2,R);
  320.       Write(D);
  321.     End;
  322.   Begin
  323.     ClrScr;
  324.     DrawBox(10,70,1,6);
  325.     HideCursor;
  326.     Center(2,'FILECAT.COM -- A FILE CATALOGING UTILITY  V2.2');
  327.     Center(3,'----------');
  328.     LowVideo;
  329.     Center(4,'Program written by Kenn Flee of Jamestown Software');
  330.     Center(5,'2508 Valley Forge Dr., Madison WI 53719  (C)1986');
  331.     NormVideo;
  332.     RestoreCursor;
  333.   End;
  334.  
  335. FUNCTION Exist(FileName : Str80) : Boolean;
  336.   VAR
  337.     Fil : file;
  338.   Begin
  339.     Assign(Fil,FileName);
  340.     {$I-}
  341.     Reset(Fil);
  342.     {$I+}
  343.     Exist := (IOResult=0);
  344.     Close(Fil);
  345.   End;
  346.  
  347. TYPE FieldType = (Af,Nf,Rf,Df,Yf);    { Alpha, Numeric, Real, Date, Yes/No }
  348.  
  349. PROCEDURE InputStr (VAR S : AnyStr;
  350.                         L,X,Y : Integer;
  351.                         FType : FieldType;
  352.                         Term : CharSet;
  353.                     VAR TC : Char);
  354.   CONST
  355.     UnderScore = '_';
  356.   VAR
  357.     P : Integer;
  358.     Ch,Ch2 : Char;
  359.     LegalChar : CharSet;
  360.     Message : Str80;
  361.     FirstChar : Boolean;
  362.     EntryString : AnyStr;
  363.     X1,X2,X3 : Integer;
  364.     Error : Boolean;
  365.   Begin
  366.     Case FType of
  367.       Af : LegalChar := [' '..'~'];             { Alpha }
  368.       Nf : LegalChar := ['-','0'..'9'];         { Numeric }
  369.       Rf : LegalChar := ['-','.','0'..'9'];     { Real }
  370.       Df : LegalChar := ['/','0'..'9'];         { Date }
  371.       Yf : LegalChar := ['Y','y','N','n'];      { Yes/No }
  372.     End; { case }
  373.     GotoXY(X,Y); Write(S,ConstStr(UnderScore,L-Length(S)));
  374.     P := 0;
  375.     FirstChar := True;
  376.     EntryString := S;
  377.     Repeat
  378.       GotoXY(X+P,Y);
  379.       Read(Kbd,Ch);
  380.       If ((Ch in [#32..#126]) and FirstChar) and FirstCharDelete then begin
  381.         P:=0;
  382.         S:='';
  383.         Write(S,ConstStr(UnderScore,L-Length(S)));
  384.         GotoXY(X+P,Y);
  385.       End;
  386.       FirstChar := False;
  387.       Case Ch of
  388.         #32..#126 : If (P<L) and (Ch in LegalChar) then
  389.                     Begin
  390.                       If FType = Yf then begin
  391.                         Case Ch of
  392.                           'Y','y' : S := 'Yes';
  393.                           'N','n' : S := 'No ';
  394.                         End;
  395.                         P:=0;
  396.                         GotoXY(X+P,Y);
  397.                         Write(S,ConstStr(UnderScore,L-Length(S)));
  398.                         Ch := #13;
  399.                       End Else begin
  400.                         If Length(S)=L then Delete(S,L,1);
  401.                         P := P+1;
  402.                         Insert(Ch,S,P);
  403.                         Write(Copy(S,P,L));
  404.                       End;
  405.                     End
  406.                     Else Beep;
  407.                ^H : If P>0 then
  408.                     Begin
  409.                       Delete(S,P,1);
  410.                       Write(^H,Copy(S,P,L),UnderScore);
  411.                       P := P-1;
  412.                     End
  413.                     Else Beep;
  414.               #27 : If KeyPressed then Begin
  415.                       Read(Kbd,Ch2);
  416.                       Case Ch2 of
  417.  
  418.                       { Func. Codes: F1=59 F2=60 F3=61 ... F10=68 }
  419.  
  420.                       #59 : Ch := ^Q;
  421.                       #62 : Begin
  422.                               P:=0;
  423.                               S:='';
  424.                               GotoXY(X+P,Y);
  425.                               Write(S,ConstStr(UnderScore,L-Length(S)));
  426.                             End;
  427.                       #66 : Begin
  428.                               FirstCharDelete := NOT FirstCharDelete;
  429.                               Ch := #13;
  430.                             End;
  431.                       #68 : Ch := ^Z;
  432.  
  433.                       { Keypad Codes:  71 72 73
  434.                                        75 76 77
  435.                                        79 80 81
  436.                                     -82- -83-    }
  437.  
  438.                       #75 : If P>0 then P := P-1
  439.                             Else Beep;
  440.                       #77 : If P<Length(S) then P := P+1
  441.                             Else Beep;
  442.                       #79 : P := Length(S);
  443.                       #71 : P := 0;
  444.                       #72 : Ch := ^E;
  445.                       #80 : Ch := ^X;
  446.                       #83 : If P<Length(S) then
  447.                             Begin
  448.                               Delete(S,P+1,1);
  449.                               Write(Copy(S,P+1,L),UnderScore);
  450.                             End;
  451.                       End; {case}
  452.                     End Else Begin
  453.                       S := EntryString;
  454.                       P:=0;
  455.                       GotoXY(X+P,Y);
  456.                       Write(S,ConstStr(UnderScore,L-Length(S)));
  457.                       Ch := #13;
  458.                     End; {begin}
  459.       End; {case}
  460.       If (Ch in Term) and (FType = Df) then begin
  461.         Error := False;
  462.         Val(Copy(S,1,2),X3,X2);
  463.         If X2<>0 then Error := True;
  464.         Val(Copy(S,4,2),X1,X2);
  465.         If X2=0 then
  466.           Case X1 of
  467.             4,6,9,11        : If NOT (X3 in [1..30]) then Error := True;
  468.             1,3,5,7,8,10,12 : If NOT (X3 in [1..31]) then Error := True;
  469.             2               : If NOT (X3 in [1..29]) then Error := True
  470.            Else Error := True;
  471.         End Else Error := True;
  472.         Val(Copy(S,7,2),X1,X2);
  473.         If X2<>0 then Error := True;
  474.         If X2=0 then If X1<85 then Error := True;
  475.         If Error then begin
  476.           Beep;
  477.           P:=0;
  478.           S:=EntryString;
  479.           GotoXY(X+P,Y);
  480.           Write(S,ConstStr(UnderScore,L-Length(S)));
  481.           Ch := #0;
  482.           FirstChar := True;
  483.         End;
  484.       End;
  485.     Until Ch in Term;
  486.     P := Length(S);
  487.     GotoXY(X+P,Y); Write('':L-P);
  488.     TC := Ch;
  489.   End;
  490.  
  491. PROCEDURE QuickSortRecord(VAR Item:EA; Count:Integer);
  492.   PROCEDURE QuickSort(SBegin,SCount:Integer;VAR It:EA);
  493.     VAR I,J:Integer;
  494.         X1,X2:E;
  495.     Begin
  496.       I:=SBegin;
  497.       J:=SCount;
  498.       X1:=It[(SBegin+SCount) div 2];
  499.       Repeat
  500.         While (It[I].EName+It[I].EExt) < (X1.EName+X1.EExt) do I:=I+1;
  501.         While (X1.EName+X1.EExt) < (It[J].EName+It[J].EExt) do J:=J-1;
  502.         If I<=J then begin
  503.           X2:=Entry[I];
  504.           Entry[I]:=Entry[J];
  505.           Entry[J]:=X2;
  506.           I:=I+1;
  507.           J:=J-1;
  508.         End;
  509.       Until I>J;
  510.       If SBegin<J then QuickSort(SBegin,J,It);
  511.       If SBegin<SCount then QuickSort(I,SCount,It);
  512.     End; { procedure QuickSort }
  513.     Begin
  514.       QuickSort(1,Count,Item);
  515.     End;  { procedure QuickSortRecord }